home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
MAINMENU.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-04
|
77KB
|
2,732 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit mainmenu;
interface
uses crt,dos,
gentypes,configrt,statret,textret,userret,mailret,modem,
gensubs,subs1,subs2,subs3,windows,chatstuf,mainr1,mainr2,overret1;
var userqr,userlistqr:integer;
u,uu:userrec;
totalused,totalidle,totalup,totaldown,totalmins,callsday,
totaldisk,totalfree,filesizes,x,y,z:real;
a,b,c:integer;
totalfiles:integer;
dofiles:boolean;
function ansiyn (str:string):boolean;
procedure calcuserqr;
procedure calcuserlistqr;
procedure editusers;
procedure zapspecifiedusers;
procedure summonsysop;
procedure offfaq;
procedure listusers;
procedure transfername;
procedure editnews;
procedure delerrlog;
procedure feedback;
procedure settime;
procedure changepwd;
procedure requestraise;
procedure makeuser;
procedure infoformhunt;
procedure donations;
procedure viewsyslog;
procedure delsyslog;
procedure changecon (con:char);
procedure showsystemstatus;
procedure showallforms;
procedure showallsysops;
procedure bbslist;
procedure searchphone;
procedure timebank;
{procedure modifycon;}
procedure readerrlog;
procedure showad;
procedure setlastcall;
procedure removeallforms;
procedure readfeedback;
procedure yourstatus;
procedure topposter;
procedure spacespace (i:integer);
implementation
function ansiyn (str:string):boolean;
var b:boolean;
c:char;
str2:string;
i,ii:integer;
begin
ii:=wherey;
i:=2;
repeat
str2:=str+'? ';
printxy2 (1,ii,^P+str2);
printxy2 (length(str2)+1,ii,^R+'Yes');
printxy2 (length(str2)+6,ii,^R+'No');
if i=1 then begin
ansicolor (31);
printxy2 (length(str2)+1,ii,'Yes');
end;
if i=2 then begin
ansicolor (31);
printxy2 (length(str2)+6,ii,'No');
end;
c:=upcase(readkey);
if c='Y' then i:=1;
if c='N' then i:=2;
if c=#13 then begin
case i of
1:b:=true;
2:b:=false;
end;
end;
until (c=#13);
ansiyn:=b;
end;
procedure calcuserqr;
begin
with u do begin
userqr := qrmultifactor*(u.uploads+u.nbu)-u.downloads;
end;
end;
procedure calcuserlistqr;
begin
with uu do begin
userlistqr := qrmultifactor*(uu.uploads+uu.nbu)-uu.downloads;
end;
end;
procedure editusers;
var eunum:integer;
matched:boolean;
procedure elistusers (getspecs:boolean);
var cnt,f,l:integer;
us:userspecsrec;
procedure listuser;
begin
write (cnt:4,' ');
tab (u.handle,31);
write (u.level:6,' ');
if useqr then begin
calcuserqr;
tab (strr(userqr),8);
end;
writeln (u.nbu:6,u.numon:6,postcallratio(u):7:2)
end;
begin
if getspecs
then if selectspecs(us)
then exit
else
begin
f:=1;
l:=numusers
end
else parserange (numusers,f,l);
seek (ufile,f);
matched:=false;
write (^B^M^M' ID# Name Level ');
if useqr then write ('QR ');
writeln ('Posts Calls PCR');
for cnt:=f to l do begin
read (ufile,u);
if (not getspecs) or fitsspecs(u,us) then begin
listuser;
matched:=true
end;
handleincoming;
if break then exit
end;
if not matched then
if getspecs
then writeln (^B^M'No users match specifications!')
else writeln (^B^M'No users found in that range!')
end;
begin
repeat
writestr (^M'[User to Edit] [?,??/List]:');
if (length(input)=0) or (match(input,'Q')) then exit;
if input[1]='?'
then elistusers (input='??')
else begin
eunum:=lookupuser (input);
if eunum=0
then writestr ('User not found!')
else edituser (eunum)
end
until hungupon
end;
procedure zapspecifiedusers;
var us:userspecsrec;
confirm:boolean;
u:userrec;
cnt:integer;
done:boolean;
begin
if selectspecs (us) then exit;
writestr ('Confirm each deletion individually? [y/n]: *');
if length(input)=0 then exit;
confirm:=yes;
if not confirm then begin
writestr (^M'Confirm each users? [y/n]: *');
if not yes then exit
end;
for cnt:=1 to numusers do begin
seek (ufile,cnt);
read (ufile,u);
if (length(u.handle)>0) and fitsspecs (u,us) then begin
if confirm
then
begin
done:=false;
repeat
writestr ('Delete '+u.handle+' [Y/N/X/E]: ');
if length(input)>0 then case upcase(input[1]) of
'Y':begin
done:=true;
writeln ('[Deleting '+u.handle+']');
deleteuser (cnt)
end;
'N':done:=true;
'X':exit;
'E':begin
edituser(cnt);
writeln;
writeln
end
end
until done
end
else
begin
writeln ('[Deleting '+u.handle+']');
if break then begin
writestr ('Aborted!');
exit
end;
deleteuser (cnt)
end
end
end
end;
procedure summonsysop;
var tf:text;
cnt:integer;
k:char;
begin
chatmode:=not chatmode;
bottomline;
if chatmode
then
if sysopisavail
then
begin
writehdr ('Page '+sysopname);
writestr ('Enter a reason to chat: &');
chatreason:=input;
if length(input)=0 then begin
chatmode:=false;
exit
end;
writelog (1,3,chatreason);
if not sblaster then begin
assign (tf,textfiledir+'Chatcall');
reset (tf);
if ioresult=0 then begin
while (not (eof(tf) or hungupon)) and chatmode do
begin
read (tf,k);
nobreak:=true;
if ord(k)=7 then summonbeep else writechar (k);
if keyhit then begin
k:=bioskey;
clearbreak;
chat1 (false)
end
end;
textclose (tf)
end;
end else begin
soundblaster ('CHATCALL.VOC');
end;
{nosound;
write (^P'[');
for cnt:=1 to 25 do begin
write(^G^G^G^G^G^G^G^G^S'.'); delay (50);
if keyhit then begin
k:=bioskey;
clearbreak;
chat1 (false);
end end; writeln(^P']');
nosound; end;}
if chatmode
then writestr ('Use [C] again to turn off page.')
else unsplit
end
else
begin
if length(notavailstr)=0 then
writestr ('Sorry, '+sysopname+
' isn''t available right now!') else
writeln (notavailstr);
chatmode:=false;
writelog (1,2,'')
end
else writestr ('Page off. Use [C] to turn it back on.');
clearbreak
end;
{procedure offfaq;
var q,n:integer;
tn:file of integer;
yesno:boolean;
m:message;
begin
writehdr ('Log off BBS');
yesno:=ansiyn (^P'Log off '^R+longname+^P);
if yesno then begin
if ulvl<msgnextlvl then begin
if exist (textfiledir+'GoodBye') then;
printfile (textfiledir+'GoodBye');
disconnect;
end;
yesno:=ansiyn (^P'Leave a message to the next user');
if yesno then begin
titlestr:='Auto-Message';
sendstr:='Next User';
q:=editor(m,false,'Auto-Message');
sendstr:='';
if q>=0 then begin
if tonext>=0 then deletetext (tonext);
tonext:=q;
writestatus
end
end;
printfile (textfiledir+'Goodbye');
disconnect;
end
end;}
procedure offfaq;
var q,n:integer;
tn:file of integer;
m:message;
begin
writehdr ('Log off BBS');
writestr ('Log off '^R+longname+^P'? [y/n]: *');
if yes then begin
if ulvl<msgnextlvl then begin
if exist (textfiledir+'GoodBye') then;
printfile (textfiledir+'GoodBye');
disconnect;
end;
writestr (^S'Leave a message to the next user? *');
if yes then begin
titlestr:='Auto-Message';
sendstr:='Next User';
q:=editor(m,false,'Auto-Message');
sendstr:='';
if q>=0 then begin
if tonext>=0 then deletetext (tonext);
tonext:=q;
writestatus
end
end;
printfile (textfiledir+'Goodbye');
disconnect;
end
end;
procedure listusers;
var cnt,u1,u2:integer;
begin
if ulvl<listuserlvl then begin
reqlevel (listuserlvl);
exit;
end;
writehdr ('List Users');
parserange (numusers,u1,u2);
if u1=0 then exit;
write (^B^P'['^S'Name'^P'] ['^S'Level'^P'] ['^S'Note'^P']');
if useqr then writeln (^P' ['^S'QR'^P'] ')
else writeln;
if break then exit;
if asciigraphics in urec.config then
write (^B^R'───────────────────────────────────────────────') else
write (^B^R'-----------------------------------------------');
if (useqr) then begin
if asciigraphics in urec.config then
write (^B^R'────────────────────────────────') else
write (^B^R'--------------------------------');
end;
writeln;
if break then exit;
for cnt:=u1 to u2 do
begin
seek (ufile,cnt);
read (ufile,uu);
che;
if length(uu.handle)>0 then begin
periods:=false;
write (^P'['^S);
tab (uu.handle,30);
if break then exit;
write (^P'] ['^S);
periods:=false;
tab (strr(uu.level),5);
if break then exit;
write (^P'] ['^S);
periods:=false;
tab (uu.note,29);
write (^P']');
if break then exit;
if useqr then begin
calcuserlistqr;
write (^P' ['^S);
tab (strr(userlistqr),4);
write (^P']');
if break then exit;
end;
writeln;
end
end
end;
procedure transfername;
var un,nlvl,ntime,tmp:integer;
u:userrec;
qaz:lstr;
begin
writehdr ('Transfer User');
if tempsysop then begin
writeln (usr,'(Disabling Temporary Sysop Access)');
ulvl:=regularlevel;
tempsysop:=false
end;
writestr ('User to transfer to:');
if length(input)=0 then exit;
un:=lookupuser(input);
if unum=un then begin
writestr ('That would be a waste of CPU time...');
exit;
end;
if un=0 then begin
writestr ('No such user.');
exit
end;
seek (ufile,un);
read (ufile,u);
if ulvl<sysoplevel then if not checkpassword(u) then begin
writelog (1,5,u.handle);
exit
end;
writelog (1,4,u.handle);
updateuserstats (false);
ntime:=0;
if datepart(u.laston)<>datepart(now) then begin
tmp:=ulvl;
if tmp<1 then tmp:=1;
if tmp>100 then tmp:=100;
ntime:=usertime[tmp]
end;
if u.timetoday<10
then if issysop or (u.level>=sysoplevel)
then
begin
writestr ('The user has '+strr(u.timetoday)+' min(s) left!');
writestr ('New time left:');
ntime:=valu(input)
end
else
if u.timetoday>0
then writeln (^P'WARNING:'^R' You have ',u.timetoday,' minutes left!')
else
begin
writestr ('Sorry, that user doesn''t have any time left!');
exit
end;
unum:=un;
readurec;
if ntime<>0 then begin
urec.timetoday:=ntime;
writeurec
end;
end;
Procedure editnews;
Var nn,numnews:Integer;
nf:File Of newsrec;
News:newsrec;
Procedure getnn(txt:mstr);
Begin
writestr(^S+'News number to '+^R+txt+^S+':');
nn:=valu(Input);
If (nn<1) Or (nn>numnews) Then nn:=0
End;
Procedure delnews;
Var cnt:Integer;
r:Integer;
NTmp:newsrec;
Begin
If nn=0 Then getnn('delete');
If nn<>0 Then Begin
Seek(nf,nn-1);
Read(nf,Ntmp);che;
deletetext(Ntmp.Location);
numnews:=FileSize(nf)-1;
For cnt:=nn To numnews Do
Begin
Seek(nf,cnt);
Read(nf,nTmp);
Seek(nf,cnt-1);
Write(nf,Ntmp)
End;
Seek(nf,numnews);
Truncate(nf)
End
End;
Procedure listnews;
Var cnt:Integer;
r,sector:Integer;
q:buffer;
l:anystr;
k:Char;
Ntmp:newsrec;
Begin
clearbreak;
WriteLn (^S' News Min Max Title ');
WriteLn (^S' Number Level Level');
WriteLn;
For cnt:=1 To numnews Do Begin
Seek(nf,cnt-1);
Read(nf,ntmp);
r:=ntmp.location;
Seek(tfile,r);
Read(tfile,q);
Write( Cnt:5 , ' ' , ntmp.level:5,' ',ntmp.maxlevel:5, ' ');
r:=1;
k:=' ';
l:='';
Writeln (ntmp.title);
{ While (Ord(k)<>13) And Not hungupon Do Begin
k:=q[r];
r:=r+1;
If (k=#0) Or (r>sectorsize) Then k:=Chr(13);
l:=l+k
End;
Write(l);}
If break Then exit
End;
{ WriteLn }
End;
Procedure viewnews;
Var r:Integer;
Ntmp:newsrec;
Begin
If nn=0 Then getnn('view');
If nn<>0 Then Begin
Seek(nf,nn-1);
Read(nf,nTmp);che;
r:=ntmp.location;
WriteLn(^M'News #',nn,' ''',ntmp.title,''' From :',ntmp.from);
WriteLn('Date: ',Datestr(ntmp.when),' Level [',ntmp.level,'-',ntmp.maxlevel,']');
printtext(r)
End
End;
Procedure adddnews;
Begin
Close(nf);
addnews;
Assign(nf,bbsdatadir+'News.dat');
Reset(nf)
End;
Var q:Integer;
Begin
Assign(nf,bbsdatadir+'News.dat');
Reset(nf);
writehdr ('New Edit');
If IOResult<>0 Then writestr('No news! Use [A] to add some!') Else Begin
Repeat
numnews:=FileSize(nf);
Write(^B^M'News entries: ',numnews);
q:=menu ('News Edit','NEWS','ADLVQ?');
nn:=valu(Copy(Input,2,255));
If (nn<1) Or (nn>numnews) Then nn:=0;
Case q Of
1:adddnews;
2:delnews;
3:listnews;
4:viewnews;
6:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
News Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔════
s');
writeln ('u
═════════════════════════════════╗HC║ [
A
]
s');
writeln ('u
Add News
║HC║ [
D
s');
writeln ('u
]
Delete News
║HC║ [
s');
writeln ('u
L
]
List News
║H
s');
writeln ('u
C║ [
Q
]
Quit
s');
writeln ('u
║HC║ [
V
]
View News
s');
writeln ('u
║HC║ [
?
]
View This Menu
s');
writeln ('u
║HC╚═══════════════════════════════
A');
writeln ('C
══════╝
');
writeln;
pause;
end;
End;
If numnews=0 Then Begin
Close(nf);
Erase(nf);
q:=5
End
Until (q=5) Or hungupon
End;
Close(nf)
End;
{procedure editnews;
var nn,numnews:integer;
nf:file of integer;
procedure getnn (txt:mstr);
begin
writestr ('News number to '+txt+':');
nn:=valu(input);
if (nn<1) or (nn>numnews) then nn:=0
end;
procedure delnews;
var cnt:integer;
r:integer;
begin
if nn=0 then getnn ('delete');
if nn<>0 then begin
seek (nf,nn-1);
read (nf,r); che;
deletetext (r);
numnews:=filesize(nf)-1;
for cnt:=nn to numnews do
begin
seek (nf,cnt);
read (nf,r);
seek (nf,cnt-1);
write (nf,r)
end;
seek (nf,numnews);
truncate (nf)
end
end;
procedure listnews;
var cnt:integer;
r,sector:integer;
q:buffer;
l:anystr;
k:char;
begin
clearbreak;
for cnt:=1 to numnews do begin
seek (nf,cnt-1);
read (nf,r);
seek (tfile,r);
read (tfile,q);
write (strr(cnt)+'. ');
r:=1;
k:=' ';
l:='';
while (ord(k)<>13) and not hungupon do begin
k:=q[r];
r:=r+1;
if (k=#0) or (r>sectorsize) then k:=chr(13);
l:=l+k
end;
writeln (l);
if break then exit
end;
writeln
end;
procedure viewnews;
var r:integer;
begin
if nn=0 then getnn ('view');
if nn<>0 then begin
seek (nf,nn-1);
read (nf,r); che;
printtext (r)
end
end;
procedure adddnews;
begin
addnews;
assign (nf,bbsdatadir+'News.dat');
close (nf);
reset (nf)
end;
var q:integer;
begin
assign (nf,bbsdatadir+'News.dat');
reset (nf);
if ioresult<>0 then writestr ('No news! Use [A] to add some!') else begin
repeat
numnews:=filesize(nf);
write (^B^M'News entries: ',numnews);
q:=menu ('News Edit','NEWS','ADLVQ?');
nn:=valu(copy(input,2,255));
if (nn<1) or (nn>numnews) then nn:=0;
case q of
1:adddnews;
2:delnews;
3:listnews;
4:viewnews
6:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
News Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔════
s');
writeln ('u
═════════════════════════════════╗HC║ [
A
]
s');
writeln ('u
Add News
║HC║ [
D
s');
writeln ('u
]
Delete News
║HC║ [
s');
writeln ('u
L
]
List News
║H
s');
writeln ('u
C║ [
Q
]
Quit
s');
writeln ('u
║HC║ [
V
]
View News
s');
writeln ('u
║HC║ [
?
]
View This Menu
s');
writeln ('u
║HC╚═══════════════════════════════
A');
writeln ('C
══════╝
');
writeln;
pause;
end;
end;
if numnews=0 then begin
close (nf);
erase (nf);
writestr ('No more news! Use [A] to add some.');
q:=5
end
until (q=5) or hungupon
end;
close (nf)
end; }
procedure delerrlog;
var e:text;
i:integer;
begin
writehdr ('Delete Error Log');
writestr ('Delete Error Log [y/n]:');
if not yes then exit;
assign (e,bbsdatadir+'errlog.dat');
reset (e);
i:=ioresult;
if ioresult=1
then writeln (^M'No error log!')
else begin
textclose (e);
erase (e);
writestr ('Error log deleted.');
if ioresult>1
then writeln ('I/O error ',i,' deleting error log!');
writelog (2,2,'')
end
end;
procedure feedback;
var m:mailrec;
me:message;
begin
writehdr ('Feedback');
writestr ('Leave Feedback to '+sysopname+' [y/n]: *');
if not yes then exit;
sendstr:='Sysop';
m.line:=editor(me,false,'Feedback');
if m.line<0 then exit;
m.title:=me.title;
m.sentby:=unam;
m.anon:=false;
m.when:=now;
addfeedback (m);
writestr ('Feedback sent.')
end;
procedure settime;
var t:integer;
n:longint;
r:registers;
d:datetime;
begin
writehdr ('Set Date/Time');
writestr ('Current Time: '+timestr(now));
writestr ('Current Date: '+datestr(now));
writestr ('Enter new time:');
if length(input)<>0
then begin
t:=timeleft;
unpacktime (timeval(input),d);
r.ch:=d.hour;
r.cl:=d.min;
r.dh:=0;
r.dl:=0;
r.ah:=$2d;
intr ($21,r);
if r.al=$ff then writestr ('Invalid time!');
settimeleft (t)
end;
writestr ('Enter new date:');
if length(input)<>0
then begin
unpacktime (dateval(input),d);
r.dl:=d.day;
r.dh:=d.month;
r.cx:=d.year;
r.ah:=$2b;
intr ($21,r);
if r.al=$ff then writestr ('Invalid date!')
end;
writelog (2,4,'')
end;
procedure changepwd;
var t:sstr;
begin
buflen:=15;
echodot:=true;
write ('Choose your new password now - Return/have one generated: ');
if getpassword
then begin
echodot:=false;
writeurec;
writestr ('Password changed.');
writelog (1,1,'')
end else begin
echodot:=false;
writestr ('No change.');
end;
end;
procedure requestraise;
var t:text;
q:lstr;
p,l1,l2:integer;
s1,s2:sstr;
me:message;
m:mailrec;
label nope,found;
begin
assign (t,textfiledir+'Raisereq');
reset (t);
if ioresult<>0 then goto nope;
printtexttopoint (t);
while not eof(t) do begin
readln (t,q);
p:=pos('-',q);
if p>0
then
begin
s1:=copy(q,1,p-1);
s2:=copy(q,p+1,255)
end
else
begin
s1:=copy(q,1,15);
s2:=s1
end;
val (s1,l1,p);
if p=0 then val (s2,l2,p);
if p<>0 then begin
textclose (t);
error ('Invalid range in RAISEREQ: %1','',q);
exit
end;
if (ulvl>=l1) and (ulvl<=l2) then goto found;
skiptopoint (t)
end;
nope:
error ('No text for level %1','',strr(ulvl));
textclose (t);
p:=ioresult;
exit;
found:
printtexttopoint (t);
textclose (t);
if hungupon then exit;
titlestr:='Raise Request';
pause;
sendstr:='Sysop';
m.line:=editor (me,false,'Raise Request');
sendstr:='';
if m.line<0 then exit;
m.anon:=false;
m.title:='Raise Request (Now Level '+strr(ulvl)+')';
m.sentby:=unam;
m.when:=now;
addfeedback (m);
end;
procedure makeuser;
var u:userrec;
i,un,ln:integer;
begin
writehdr ('Add a User');
writestr ('Name:');
if length(input)=0 then exit;
if lookupuser(input)<>0 then begin
writestr ('Sorry! Already exists!');
exit
end;
u.handle:=input;
writestr ('Password:');
u.password:=input;
writestr ('Level:');
if length(input)=0 then exit;
u.level:=valu(input);
u.note:=newusernote;
for i:=1 to 5 do begin
u.defcon[i]:=defconfm[i];
u.defcon[i+5]:=defconfx[i];
end;
un:=adduser(u);
if un=-1 then begin
writestr ('Sorry, no room for new users!');
exit
end;
ln:=u.level;
if ln<1 then ln:=1;
if ln>100 then ln:=100;
u.timetoday:=usertime[ln];
writeufile (u,un);
writestr ('User added as #'+strr(un)+'.');
writelog (2,8,u.handle)
end;
procedure infoformhunt;
begin
writestr ('User to search for [CR/All users]:');
writeln (^M);
showinfoforms (input)
end;
procedure donations;
var fn:lstr;
begin
writehdr ('Donations');
fn:=textfiledir+'Donation';
if exist (fn)
then printfile (fn)
else begin
writestr ('I''m sorry, no information is currently available.');
if issysop
then writestr (
'Sysop: To create donation information text, make a file called '+fn)
end
end;
procedure viewsyslog;
var n:integer;
l:logrec;
function lookupsyslogdat (m,s:integer):integer;
var cnt:integer;
begin
for cnt:=1 to numsyslogdat do with syslogdat[cnt] do
if (menu=m) and (subcommand=s) then begin
lookupsyslogdat:=cnt;
exit
end;
lookupsyslogdat:=0
end;
function firstentry:boolean;
begin
firstentry:=(l.menu=0) and (l.subcommand in [1..2])
end;
procedure backup;
begin
while n<>0 do begin
n:=n-1;
seek (logfile,n);
read (logfile,l);
if firstentry then exit
end;
n:=-1
end;
procedure showentry (includedate:boolean);
var q:lstr;
p:integer;
begin
q:=syslogdat[lookupsyslogdat(l.menu,l.subcommand)].text;
p:=pos('%',q);
if p<>0 then q:=copy(q,1,p-1)+l.param+copy(q,p+1,255);
if includedate then q:=q+' on '+datestr(l.when);
q:=timestr(l.when)+' - '+q;
writeln (q)
end;
var b:boolean;
begin
writehdr ('View System Log');
writeln ('Press [Space] to advance to the previous caller, [X] to abort.');
writeln;
writelog (2,6,'');
n:=filesize(logfile);
repeat
clearbreak;
writeln (^M);
backup;
if n=-1 then exit;
seek (logfile,n);
read (logfile,l);
showentry (true);
b:=false;
while not (eof(logfile) or break or xpressed or b) do begin
read (logfile,l);
b:=firstentry;
if not b then showentry (false);
end
until xpressed
end;
procedure delsyslog;
begin
writehdr ('Delete System Log');
writestr ('Delete the System Log [y/n]:');
if not yes then exit;
close (logfile);
rewrite (logfile);
writeln (^M'Deleted.');
writelog (2,7,unam)
end;
procedure changecon (con:char);
procedure listcon (k:char);
var i:integer;
begin
writehdr ('Conference List');
if ascii then begin
writeln (^R'┌───┬───────────────────────────────────────────────────────────┐');
writeln (^R'│ '^S'# '^R'│ '^S'Conference Name '^R'│');
writeln (^R'├───┼───────────────────────────────────────────────────────────┤');
end else begin
writeln (^R'+---+-----------------------------------------------------------+');
writeln (^R'| '^S'# '^R'| '^S'Conference Name '^R'|');
writeln (^R'|---|-----------------------------------------------------------|');
end;
for i:=1 to 5 do begin
if (k='M') then if (urec.defcon[i]) and (length(confm[i])>0) then begin
if ascii then write (^R'│ ') else write (^R'| ');
tab (^S+strr(i),3);
if ascii then write (^R'│ ') else write (^R'| ');
tab (^S+confm[i],59);
if ascii then writeln (^R'│') else writeln (^R'|');
end;
if (k='X') then if (urec.defcon[i+5]) and (length(confx[i])>0) then begin
if ascii then write (^R'│ ') else write (^R'| ');
tab (^S+strr(i),3);
if ascii then write (^R'│ ') else write (^R'| ');
tab (^S+confx[i],59);
if ascii then writeln (^R'│') else writeln (^R'|');
end;
end;
if ascii then
writeln (^R'└───┴───────────────────────────────────────────────────────────┘')
else writeln (^R'+---+-----------------------------------------------------------+');
writeln;
end;
var n:char;
c:byte;
begin
if (conn<0) or (conn>5) then conn:=1;
if (useconf) then begin
c:=conn;
repeat
buflen:=1;
writestr (^R'Enter Conference # '^P'['^S'?'^P'/'^R'List'^P']'^S': *');
n:=upcase(input[1]);
case n of
'?':listcon (con);
'1':if con='M' then
if (not urec.defcon[1]) or (length(confm[1])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=1; exit; end else
if con='X' then
if (not urec.defcon[6]) or (length(confx[1])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=1; exit; end;
'2':if con='M' then
if (not urec.defcon[2]) or (length(confm[2])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=2; exit; end else
if con='X' then
if (not urec.defcon[7]) or (length(confx[2])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=2; exit; end;
'3':if con='M' then
if (not urec.defcon[3]) or (length(confm[3])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=3; exit; end else
if con='X' then
if (not urec.defcon[8]) or (length(confx[3])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=3; exit; end;
'4':if con='M' then
if (not urec.defcon[4]) or (length(confm[4])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=4; exit; end else
if con='X' then
if (not urec.defcon[9]) or (length(confx[4])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=4; exit; end;
'5':if con='M' then
if (not urec.defcon[5]) or (length(confm[5])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=5; exit; end else
if con='X' then
if (not urec.defcon[10]) or (length(confx[5])<1)
then writeln (^R^M'No Such Conference!') else begin
conn:=5; exit; end;
end;
until ((n='1') and (length(confm[1])>0) and (urec.defcon[1])) or
((n='1') and (length(confx[1])>0) and (urec.defcon[6])) or
((n='2') and (length(confm[2])>0) and (urec.defcon[2])) or
((n='2') and (length(confx[2])>0) and (urec.defcon[7])) or
((n='3') and (length(confm[3])>0) and (urec.defcon[3])) or
((n='3') and (length(confx[3])>0) and (urec.defcon[8])) or
((n='4') and (length(confm[4])>0) and (urec.defcon[4])) or
((n='4') and (length(confx[4])>0) and (urec.defcon[9])) or
((n='5') and (length(confm[5])>0) and (urec.defcon[5])) or
((n='5') and (length(confx[5])>0) and (urec.defcon[10]));
end else begin conn:=0; exit; end;
end;
procedure showsystemstatus;
var totalused,totalidle,totalup,totaldown,totalmins,callsday:real;
yiyiyi:integer;
drv:array [1..15] of boolean;
procedure diskcalcs;
var cnt,cnt2,curarea:integer;
ar,area:arearec;
ud:udrec;
inscan,showit,fast:boolean;
procedure assignud;
var con1:byte;
begin
for con1:=1 to 5 do
assign (udfile,datadir+'AREA'+strr(curarea)+'.'+strr(con1))
end;
const beenaborted:boolean=false;
function aborted:boolean;
begin
if beenaborted then begin
aborted:=true;
exit
end;
aborted:=xpressed or hungupon;
if xpressed then begin
beenaborted:=true;
writeln (^B'Aborted!')
end
end;
procedure setarea (n:integer);
begin
curarea:=n;
seek (afile,n-1);
read (afile,area);
close (udfile);
assignud;
close (udfile);
reset (udfile);
if ioresult<>0 then rewrite (udfile);
end;
procedure checkdrive (dv:char);
var n:byte;
tempdisk,tempfree:real;
procedure writefreespace (dr:byte);
var r:registers;
csize:real;
function unsigned (i:integer):real;
begin
if i>=0 then unsigned:=i else unsigned:=65536.0+i
end;
begin
r.ah:=$36;
r.dl:=dr;
intr ($21,r);
if r.ax=-1 then exit;
csize:=unsigned(r.ax)*unsigned(r.cx);
tempfree:=(csize*unsigned(r.bx))/1000;
tempdisk:=(csize*unsigned(r.dx))/1000;
end;
begin
if (ord(dv)<65) or (ord(dv)>79) then exit;
n:=ord(dv)-64;
writefreespace(n);
if not drv[n] then begin
drv[n]:=true;
totaldisk:=totaldisk+tempdisk;
totalfree:=totalfree+tempfree;
end;
end;
function getfname (path:lstr; name:mstr):lstr;
var l:lstr;
begin
l:=path;
if length(l)<>0 then if not (upcase(l[length(l)]) in [':','\'])
then l:=l+'\';
l:=l+name;
getfname:=l
end;
var con1:byte;
begin
totalfiles:=0;
filesizes:=0;
totaldisk:=0;
totalFree:=0;
for cnt:=1 to 15 do drv[cnt]:=false;
for con1:=1 to 5 do begin
assign (afile,datadir+'Areadir.'+strr(con1));
if exist (datadir+'Areadir.'+strr(con1)) then begin
reset (afile);
if filesize (afile)<0 then exit
end
else rewrite (afile);
end;
cnt:=1;
while (cnt<=filesize(afile)) do begin
seek (afile,cnt-1);
read (afile,ar);
checkdrive (upcase(ar.xmodemdir[1]));
setarea (cnt);
for cnt2:=filesize (udfile) downto 1 do begin
seek (udfile,cnt2-1);
read (udfile,ud);
checkdrive (upcase(ud.path[1]));
if aborted then begin
totalfiles:=0;
filesizes:=0;
totaldisk:=0;
totalfree:=0;
exit;
end;
if exist (getfname(ud.path,ud.filename)) then begin
totalfiles:=totalfiles+1;
filesizes:=filesizes+ud.filesize;
end;
end;
cnt:=cnt+1;
end;
filesizes:=filesizes/1000;
end;
procedure percent (prompt:mstr; top,bot:real);
var p:real;
begin
write (prompt);
if bot<1 then begin
writeln ('N/A');
exit
end;
p:=round(1000*top/bot)/10;
writeln (p:0:1,'%')
end;
procedure modemstatus;
function getbaudstr (var q:baudset):lstr;
var w:lstr;
cnt:baudratetype;
begin
w[0]:=chr(0);
for cnt:=firstbaud to lastbaud do
if cnt in q then w:=w+strlong(baudarray[cnt])+' ';
if length(w)=0 then w:='None';
getbaudstr:=w
end;
begin
writehdr ('Modem Status');
writeln (^R'COM Port'^P': '^S+strr(usecom));
writeln (^R'Characters Sent'^P': '^S+strlong(bsent));
writeln (^R'Characters Received'^P': '^S+strlong(brecv));
writeln (^R'Current Baud Rate'^P': '^S+strlong(baudrate));
writeln (^R'Default Baud Rate'^P': '^S+strlong(defbaudrate));
writeln (^R'Supported Baud Rates'^P': '^S+getbaudstr(supportedrates));
writeln (^R'Downloaded Baud Rates'^P': '^S+getbaudstr(downloadrates));
write (^R'Connected with MNP/ARQ'^P': ');
if arq then writeln (^S'Yes') else writeln (^S'No');
writeln (^R'Modem Routines/Version'^P': '^S'FAQ/PibaSync Version '+ver);
writeln (^R);
end;
label last;
var ozzy,anarky:anystr;
c:char;
metallica:integer;
begin
writehdr ('BBS Statistics');
repeat
writestr (^S'M'^R'odem Status '^S'S'^R'ystem Status '^S'Q'^R'uit'^P': '^U'*');
c:=upcase(input[1]);
case c of
'M':begin modemstatus; c:=#0; end;
'S':begin
writehdr ('System Status');
dofiles:=false;
totalused:=numminsused.total+elapsedtime(numminsused);
totalidle:=numminsidle.total;
totalup:=totalidle+numminsused.total;
totalmins:=1440.0*(numdaysup-1.0)+timer;
totaldown:=totalmins-totalup;
callsday:=round(10*numcallers/numdaysup)/10;
{writestr ('Calculate Disk Storages & File Area Stats? [y/n]: *');
writeln;
if yes then begin
writeln ('Calculating.');
dofiles:=true;
diskcalcs;
end;}
ozzy:=ver+' - '+parsedate(date);
writeln ('[FAQ Version]: '^S,ozzy);
writeln ('[Time & Date]: '^S,timestr(now),', ',datestr(now));
writeln ('[Calls today]: '^S,callstoday);
writeln ('[Total callers]: '^S,numcallers:0:0);
writeln ('[Total days up]: '^S,numdaysup);
writeln ('[Calls per day]: '^S,callsday:0:1);
writeln ('[Total mins in use]: '^S,numminsused.total:0:0);
writeln ('[Total mins idle]: '^S,totalidle:0:0);
writeln ('[Mins file xfer]: '^S,numminsxfer.total:0:0);
writeln ('[Total mins up]: '^S,totalup:0:0);
writeln ('[Total mins down]: '^S,totaldown:0:0);
percent ('[% BBS is in use]: '^S,totalused,totalmins);
percent ('[% BBS is idle]: '^S,totalidle,totalmins);
percent ('[% BBS is up]: '^S,totalup,totalmins);
percent ('[% BBS is down]: '^S,totaldown,totalmins);
{if dofiles then begin
percent ('[% Space Unused]: '^S,totalfree,totaldisk);
percent ('[% Space Used]: '^S,(totaldisk-totalfree),totaldisk);
percent ('[% Storage Online]: '^S,filesizes,totaldisk);
writeln ('[Files Online]: '^S,totalfiles);
writeln ('[Files Storage]: '^S,streal (filesizes/1000),' Megabytes');
writeln ('[Total Storage]: '^S,streal (totaldisk/1000),' Megabytes');
writeln ('[Upload Space]: '^S,streal (totalfree/1000),' Megabytes');
write ('[Drives Online]: '^S);
for yiyiyi:=1 to 15 do
if drv[yiyiyi] then write ('['+chr(yiyiyi+64),']: ');
end;
writeln (^R);}
c:=#0;
end;
end;
until (c='Q') or (c='q');
end;
procedure showallforms;
begin
showinfoforms ('')
end;
procedure showallsysops;
var n:integer;
u:userrec;
q:set of configtype;
s:configtype;
procedure showuser;
const sectionnames:array [udsysop..databasesysop] of string[20]=
('File transfer','Bulletin section','Voting booths',
'E-mail section','Doors','Main Menu','Databases');
var s:configtype;
begin
writeln (#27'[2J');
writeln (^R'┌─────────┬──────────────────────────────┐');
writeln ('│'^P'Name'^R' │ │');
Writeln ('│'^P'Level'^R' │ │');
Writeln ('│'^P'Password'^R' │ │');
writeln (^R'└─────────┴──────────────────────────────┘');
printxy (12,3,^S+u.handle);
printxy (12,4,strr(u.level));
printxy (12,5,u.password);
writestr (^M'Edit user? [y/n]: *');
if yes then edituser (n)
end;
begin
q:=[];
for s:=udsysop to databasesysop do q:=q+[s];
for n:=1 to numusers do begin
seek (ufile,n);
read (ufile,u);
if (u.level>=sysoplevel) or (q*u.config<>[]) then showuser
end
end;
procedure bbslist;
var card,ugbot,p:lstr;
b:bbsrec;
function numbbses:integer;
begin
numbbses:=filesize(blfile)
end;
procedure seekblfile (n:integer);
begin
seek (blfile,n-1);
end;
function numbbs:integer;
begin
numbbs:=filesize (blfile);
end;
procedure getstring (t:lstr; var m; buf:integer);
var q:lstr absolute m;
mm:lstr;
begin
writeln (^R'Old ',t,': '^S,q,^R);
buflen:=buf;
writestr ('Enter new '+t+' [CR/no change]:');
mm:=input;
if length(mm)<>0 then q:=mm;
writeln
end;
procedure listbbs;
var cnt,b1,b2:integer;
showedz:boolean;
begin
writehdr ('BBS List');
reset (blfile);
if ioresult<>0 then begin
writeln ('There are no BBS''s in the list. Add one!');
exit;
end
else begin
parserange (numbbs,b1,b2);
writestr ('Show Extended BBS Descriptions? [Y/n]: *');
writeln;
showedz:=true;
if (upcase(input[1])='N') then showedz:=false;
if b1>0 then
for cnt:=b1 to b2 do
begin
seekblfile (cnt);
read (blfile,b);
write (^R'['^S);
tab (b.number,12);
write (^R' '^P);
tab (b.name,48);
write (^R' '^U);
tab (b.maxbaud,4);
write (^R' '^P);
tab (b.ware,8);
writeln (^R']');
if showedz then
begin
write (^R':'^U);
tab (b.extdesc,77);
writeln (^R'');
end;
end;
end;
end;
function getbnum (txt:mstr):integer;
var n:integer;
begin
getbnum:=0;
repeat
writeln;
writestr ('BBS Number to '+txt+' [?/List]:');
if length(input)=0 then exit;
if upcase(input[1])='?'
then listbbs
else begin
n:=valu(input);
if (n<1) or (n>numbbs) then begin
writestr (^M'Number out of range!');
exit
end;
seekblfile (n);
read (blfile,b);
getbnum:=n;
exit
end
until hungupon
end;
procedure addbbs;
begin
writehdr ('Add a BBS');
writeln (^R'Phone Number [12 Characters Max]');
writeln (^R' [------------]');
buflen:=12;
writestr (': &');
b.number:=input;
writeln;
writeln (^R'Enter BBS Name [48 Characters Max]');
writeln (^R' [------------------------------------------------]');
buflen:=48;
writestr (': &');
b.name:=input;
writeln;
writeln (^R'Maximum Baud [4 Digits] (ie 2400,4800,9600,19.2)');
writeln (^R' [----]');
buflen:=4;
writestr (': &');
b.maxbaud:=input;
writeln;
writeln (^R'BBS Software [8 Characters Max] (ie FAQ,TCS,Celerity)');
writeln (^R' [--------]');
buflen:=8;
writestr (': &');
b.ware:=input;
writeln;
writeln (^R'Extended BBS Description [77 Characters Max - CR for none]');
writeln(^R' [-------------------------------------------------------------------------]');
buflen:=77;
writestr (': &');
b.extdesc:=input;
b.leftby:=unam;
b.when:=now;
if (length(b.number)>0) and (length(b.name)>0) and (length(b.maxbaud)>0)
and (length(b.ware)>0) then begin
if not exist (bbsdatadir+'BBSList.dat') then rewrite (blfile);
seekblfile (numbbses+1);
write (blfile,b);
writeln (^M^S'Entry Added!'^R^M);
writelog (6,1,b.name);
end else
writeln (^M^S'Entry incomplete!'^R^M);
end;
procedure changebbs;
var q,spock:integer;
doodzdomain:char;
phortune:boolean;
procedure showbbs (b:bbsrec);
begin
writeln (^M^R'['^S'1'^R'] BBS Name: '^S,b.name,
^M^R'['^S'2'^R'] BBS Number: '^S,b.number,
^M^R'['^S'3'^R'] Max Baud: '^S,b.maxbaud,
^M^R'['^S'4'^R'] BBS Software: '^S,b.ware,
^M^R'['^S'5'^R'] Extended BBS Description:',
^M^R': '^S,b.extdesc,
^M^R'['^S'Q'^R'] Quit');
end;
begin
reset (blfile);
if ioresult<>0 then begin
writeln ('There are no BBS''s in the list. Add one!');
exit;
end;
writehdr ('Change an Entry');
phortune:=false;
repeat
writestr (^M'Entry to Change [?/List]: &');
if input[1]='?' then listbbs else begin
spock:=valu(input);
if spock<1 then exit;
if spock>numbbs then exit;
seekblfile (spock);
read (blfile,b);
if (not (match (b.leftby,unam))) and (ulvl<sysoplevel) then begin
writeln (^M'You didn''t post that entry!'^M);
exit;
end;
phortune:=true;
writelog (16,3,b.name);
repeat
showbbs (b);
writestr ('[Edit BBS List Command] [?/Help]: *');
doodzdomain:=upcase(input[1]);
case doodzdomain of
'1':getstring ('BBS Name',b.name,48);
'2':getstring ('BBS Number',b.number,12);
'3':getstring ('Maximum Baud',b.maxbaud,4);
'4':getstring ('BBS Software',b.ware,8);
'5':begin
writeln ('Old Extended BBS Description:');
writeln (': ',b.extdesc);
writeln ('Enter new Extended BBS Description [CR/no change]:');
buflen:=77;
writestr (': &');
if length(input)<>0 then b.extdesc:=input;
writeln
end;
'Q':;
end;
until doodzdomain='Q';
seekblfile (spock);
write (blfile,b);
end;
until phortune;
end;
procedure deletebbs;
var i,n,cnt:integer;
c:char;
maniaclame:boolean;
begin
reset (blfile);
if ioresult<>0 then begin
writeln ('There are no BBS''s in the list. Add one!');
exit;
end;
writehdr ('Delete an Entry');
n:=getbnum ('Delete');
if n=0 then exit;
seekblfile (n);
read (blfile,b);
if not issysop then
if not match(b.leftby,unam) then begin
writeln;
writeln ('You didn''t enter that!');
writeln;
exit;
end;
writeln;
writeln (^R'['^S,b.name,^R'] ['^S,b.number,^R']');
writeln;
writestr ('Delete this entry? [y/n]: *');
if not yes then exit;
writelog (6,2,b.name);
for cnt:=n to numbbs-1 do begin
seekblfile (cnt+1);
read (blfile,b);
seekblfile (cnt);
write (blfile,b)
end;
seekblfile (numbbs);
truncate (blfile);
{ writelog ('Deleted BBS Entry "',b.leftby,'"'); }
end;
procedure searchbbstext;
var x:integer;
ariescool:boolean;
s:anystr;
bb:bbsrec;
begin
reset (blfile);
if ioresult<>0 then begin
writeln ('There are no BBS''s in the list. Add one!');
exit;
end;
writehdr ('Search for Text in BBS List');
writeln ('Enter text to search for:');
writestr (': &');
writeln;
if length(input)=0 then exit;
s:=input;
s:=upstring(s);
for x:=1 to numbbs do begin
ariescool:=false;
seekblfile (x);
read (blfile,bb);
if pos(s,upstring(bb.number))<>0 then ariescool:=true;
if pos(s,upstring(bb.name))<>0 then ariescool:=true;
if pos(s,upstring(bb.maxbaud))<>0 then ariescool:=true;
if pos(s,upstring(bb.ware))<>0 then ariescool:=true;
if pos(s,upstring(bb.extdesc))<>0 then ariescool:=true;
if ariescool=true then begin
write (^R'['^S);
tab (bb.number,12);
write (^R' '^P);
tab (bb.name,48);
write (^R' '^U);
tab (bb.maxbaud,4);
write (^R' '^P);
tab (bb.ware,8);
writeln (^R']');
write (^R':'^U);
tab (bb.extdesc,77);
writeln (^R'');
end;
end;
end;
procedure newscanbbs;
var cnt:integer;
bb:bbsrec;
begin
reset (blfile);
if ioresult<>0 then begin
writeln ('There are no BBS''s in the list. Add one!');
exit;
end;
writehdr ('BBS List Newscan');
for cnt:=1 to numbbs do begin
seekblfile (cnt);
read (blfile,bb);
if (bb.when>laston) then begin
write (^R'['^S);
tab (bb.number,12);
write (^R' '^P);
tab (bb.name,48);
write (^R' '^U);
tab (bb.maxbaud,4);
write (^R' '^P);
tab (bb.ware,8);
writeln (^R']');
write (^R':'^U);
tab (bb.extdesc,77);
writeln (^R'');
end;
end;
end;
procedure sortbbs;
begin
reset (blfile);
if ioresult<>0 then begin
writeln ('There are no BBS''s in the list. Add one!');
exit;
end
end;
procedure converttextfile;
var x:integer;
t:text;
begin
reset (blfile);
if ioresult<>0 then begin
writeln ('There are no BBS''s in the list. Add one!');
exit;
end;
assign (t,bbsdatadir+'BBSLIST.TXT');
rewrite (t);
textclose (t);
end;
procedure bbslistsysop;
begin
if ulvl<sysoplevel then begin
reqlevel (sysoplevel);
exit;
end;
writelog (6,4,unam);
writeln;
repeat
ugbot:=' ';
writeln (^R'['^S'D'^R'] Delete an Entry');
writeln (^R'['^S'C'^R'] Change an Entry');
writeln (^R'['^S'S'^R'] Sort Entries');
writeln (^R'['^S'Q'^R'] Quit');
writeln;
writestr ('[BBS List Sysop Command]: *');
ugbot:=upstring(input);
case ugbot[1] of
'D':deletebbs;
'C':changebbs;
'S':sortbbs;
end;
until (ugbot[1]='Q');
end;
label exit;
var q:integer;
begin
assign (blfile,bbsdatadir+'BBSList.dat');
if exist (bbsdatadir+'BBSList.dat') then reset (blfile);
writehdr ('BBS List');
repeat
q:=menu ('BBS List','BBSLIST','LADC%QNS?');
writeln;
case q of
1:listbbs;
2:addbbs;
3:deletebbs;
4:changebbs;
5:bbslistsysop;
6:goto exit;
7:newscanbbs;
8:searchbbstext;
9:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
BBS List Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔════
s');
writeln ('u
═════════════════════════════════╗HC║ [
A
]
s');
writeln ('u
Add BBS Entry to List
║HC║ [
C
s');
writeln ('u
]
Change BBS Entry
║HC║ [
s');
writeln ('u
D
]
Delete BBS Entry from List
║H
s');
writeln ('u
C║ [
L
]
List BBS Entries
s');
writeln ('u
║HC║ [
N
]
Newscan BBS Entries
s');
writeln ('u
║HC║ [
Q
]
Quit
s');
writeln ('u
║HC║ [
S
]
Search BBS
s');
writeln ('u
Entries for Text
║HC║ [
%
]
BBS
s');
writeln ('u
List Sysop Section
║HC║ [
?
]
s');
writeln ('u
View This Menu
║HC╚═════════
A');
writeln ('C
════════════════════════════╝
');
write (^B^R' '^M);
pause;
end;
end;
until (hungupon) or (q=6);
exit:
close (blfile);
end;
procedure searchphone;
var temp:sstr;
user:userrec;
cnt,int:integer;
begin
int:=0;
writeln (^R'Phone Number without dashes'^P', '^R'slashes'^P', '^R'etc'^P'.');
buflen:=15;
writestr (^P': '^U'*');
if length(input)<10 then exit;
temp:=input;
writeln;
for cnt:=1 to numusers do begin
seek (ufile,cnt);
read (ufile,user);
if match(temp,user.phonenum) then begin
writeln (^R'User with #'^S+user.phonenum+^P': '^R'#'^S,cnt,' '+user.handle,^M);
int:=int+1;
end; end;
writeln (^R'# of Users found with Phone Number'^P': '^S,int);
write (^B^R);
end;
procedure timebank;
var q:char;
procedure setuplocal;
var i:integer;
begin
assign(bnkfile,bbsdatadir+'TIMEBANK.DAT');
if not exist(bbsdatadir+'timebank.dat') then begin
rewrite(bnkfile);
acct.balance:=0;
acct.lastw:=0;
acct.lastt:=' ';
acct.lasta:=0;
for i:=1 to 1200 do write(bnkfile,acct);
end;
reset(bnkfile); seek(bnkfile,unum-1);
read(bnkfile,acct);
end;
procedure writebank;
begin
seek(bnkfile,unum-1); write(bnkfile,acct);
end;
procedure showbalance;
begin
writeln('Account #'+strr(unum)+' - '+unam); writeln;
writeln('Current balance : '^S,acct.balance,^R' minutes.');
writeln('Maximum deposit : '^S,strr(maxdeposit));
write('Last Transaction: '^S);
case acct.lastt of
'W' : write('Withdrawal');
'D' : write('Deposit');
else begin
writeln('None');
writeln;
exit;
end;
end;
writeln(^R' of '^P,acct.lasta,^R' minutes on '^P,datestr(acct.lastw),^R);
writeln;
end;
procedure deposit;
var amt:integer;
begin
writeln;
if urec.timetoday <= 5 then begin
writeln('You have only ',urec.timetoday,' now!');
exit;
end;
if acct.balance = maxdeposit then begin
writeln('The time bank only insures you up to '+strr(maxdeposit)+' minutes!');
exit;
end;
showbalance;
writestr('Deposit how many minutes? &');
amt:=valu(input); writeln;
if amt <= 0 then exit;
if amt > urec.timetoday then begin
writeln('You haven''t got that much left!');
exit;
end;
if amt+acct.balance > maxdeposit then begin
writeln('The time bank will only insure up to '+strr(maxdeposit)+' minutes, would you settle for');
write ('depositing only '+strr(maxdeposit-acct.balance)+' minutes instead? ');
writestr('&');
if upcase(input[1])<>'Y' then exit;
amt:=maxdeposit-acct.balance;
end;
acct.lasta:=amt;
acct.lastw:=now;
acct.lastt:='D';
acct.balance:=acct.balance+amt;
urec.timetoday:=urec.timetoday-amt;
writebank;
writeln(^S,amt,^R' minutes added to your account.');
end;
procedure withdraw;
var amt:integer;
begin
writeln;
if acct.balance <= 0 then acct.balance:=0;
if acct.balance = 0 then begin
writeln('You have nothing to withdraw!');
exit;
end;
showbalance;
writestr('Withdraw how many minutes? &');
amt:=valu(input); writeln;
if amt <= 0 then exit;
if amt > acct.balance then begin
writeln('You haven''t got that much in your account.');
exit;
end;
acct.lasta:=amt;
acct.lastw:=now;
acct.lastt:='W';
acct.balance:=acct.balance-amt;
urec.timetoday:=urec.timetoday+amt;
writebank;
writeln(^S,amt,^R' minutes added to today''s time.');
end;
begin
if (usetimebank) then begin
setuplocal;
repeat
showbalance;
writeln (^P'['^S'D'^P'] '^R'Deposit Time');
writeln (^P'['^S'W'^P'] '^R'Withdraw Time');
writeln (^P'['^S'Q'^P'] '^R'Quit');
writestr(^M^P'['^R'Time Bank Menu'^P']'^S': '^U'*');
q:=upcase(input[1]);
case q of
'W': withdraw;
'D': deposit;
end
until (q='q') or (q='Q') or (hungupon)
end else begin writeln ('Timebank is not configured.'); exit; end;
end;
{procedure modifycon;
var choice:char;
choice1,choice2,choice3,choice4,choice5:char;
procedure writeconfig;
var q:file of configsettype;
begin
assign (q,'SETUP.CFG');
rewrite (q);
write (q,configset);
close (q)
end;
begin
repeat
writehdr ('Modify Conferences');
writeln (^R'['^S'A'^R'] Conference #1: '^S+conf1);
writeln (^R'['^S'B'^R'] Conference #2: '^S+conf2);
writeln (^R'['^S'C'^R'] Conference #3: '^S+conf3);
writeln (^R'['^S'D'^R'] Conference #4: '^S+conf4);
writeln (^R'['^S'E'^R'] Conference #5: '^S+conf5);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Sysop Command'^P']'^S': *');
choice:=upcase(input[1]);
if choice='A' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #1 Name : '^S+conf1);
writeln (^R'['^S'B'^R'] Conference #1 Sponsor : '^S+con1spon);
writeln (^R'['^S'C'^R'] Conference #1 Entry PW: '^S+con1pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
choice1:=upcase(input[1]);
if choice1='A' then begin writestr ('Input: *'); conf1:=input; end;
if choice1='B' then begin writestr ('Input: *'); con1spon:=input; end;
if choice1='C' then begin writestr ('Input: *'); con1pw:=input; end;
until (choice1='Q');
writeconfig;
end;
if choice='B' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #2 Name : '^S+conf2);
writeln (^R'['^S'B'^R'] Conference #2 Sponsor : '^S+con2spon);
writeln (^R'['^S'C'^R'] Conference #2 Entry PW: '^S+con2pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
choice2:=upcase(input[1]);
if choice2='A' then begin writestr ('Input: *'); conf2:=input; end;
if choice2='B' then begin writestr ('Input: *'); con2spon:=input; end;
if choice2='C' then begin writestr ('Input: *'); con2pw:=input; end;
until (choice2='Q');
writeconfig;
end;
if choice='C' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #3 Name : '^S+conf3);
writeln (^R'['^S'B'^R'] Conference #3 Sponsor : '^S+con3spon);
writeln (^R'['^S'C'^R'] Conference #3 Entry PW: '^S+con3pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
choice3:=upcase(input[1]);
if choice3='A' then begin writestr ('Input: *'); conf3:=input; end;
if choice3='B' then begin writestr ('Input: *'); con3spon:=input; end;
if choice3='C' then begin writestr ('Input: *'); con3pw:=input; end;
until (choice3='Q');
writeconfig;
end;
if choice='D' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #4 Name : '^S+conf4);
writeln (^R'['^S'B'^R'] Conference #4 Sponsor : '^S+con4spon);
writeln (^R'['^S'C'^R'] Conference #4 Entry PW: '^S+con4pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
choice4:=upcase(input[1]);
if choice4='A' then begin writestr ('Input: *'); conf4:=input; end;
if choice4='B' then begin writestr ('Input: *'); con4spon:=input; end;
if choice4='C' then begin writestr ('Input: *'); con4pw:=input; end;
until (choice4='Q');
writeconfig;
end;
if choice='E' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #5 Name : '^S+conf5);
writeln (^R'['^S'B'^R'] Conference #5 Sponsor : '^S+con5spon);
writeln (^R'['^S'C'^R'] Conference #5 Entry PW: '^S+con5pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
choice5:=upcase(input[1]);
if choice5='A' then begin writestr ('Input: *'); conf5:=input; end;
if choice5='B' then begin writestr ('Input: *'); con5spon:=input; end;
if choice5='C' then begin writestr ('Input: *'); con5pw:=input; end;
until (choice5='Q');
writeconfig;
end;
until (choice='Q');
writeconfig;
end;}
procedure readerrlog;
begin
writehdr ('Read Error Log');
if exist (bbsdatadir+'Errlog.dat')
then printfile (bbsdatadir+'Errlog.dat')
else writestr ('No error file!')
end;
procedure showad;
var fn:lstr;
begin
writehdr ('Advertisement');
fn:=textfiledir+'FAQ.Ad';
if exist (fn) then printfile (fn) else begin
writeln (^M'No Advertisement.'^M);
writeln (usr,'Sysop: To make one, create a file called FAQ.AD in your Menus Directory.'^M);
end;
end;
procedure setlastcall;
function digit (k:char):boolean;
begin
digit:=ord(k) in [48..57]
end;
function validtime (inp:sstr):boolean;
var c,s,l:integer;
d1,d2,d3,d4:char;
ap,m:char;
begin
validtime:=false;
l:=length(inp);
if (l<7) or (l>8) then exit;
c:=pos(':',inp);
if c<>l-5 then exit;
s:=pos(' ',inp);
if s<>l-2 then exit;
d2:=inp[c-1];
if l=7
then d1:='0'
else d1:=inp[1];
d3:=inp[c+1];
d4:=inp[c+2];
ap:=upcase(inp[s+1]);
m:=upcase(inp[s+2]);
if d1='1' then if d2>'2' then d2:='!';
if (d1>='0') and (d1<='1') and digit(d2) and (d3>='0') and (d3<='5')
and digit(d4) and ((ap='A') or (ap='P')) and (m='M')
then validtime:=true
end;
function validdate (inp:sstr):boolean;
var k,l:char;
function gchar:char;
begin
if length(inp)=0 then begin
gchar:='?';
exit
end;
gchar:=inp[1];
delete (inp,1,1)
end;
begin
validdate:=false;
k:=gchar;
l:=gchar;
if not digit(k) then exit;
if l='/'
then if k='0'
then exit
else
else begin
if k>'1' then exit;
if not digit(l) then exit;
if (l>'2') and (k='1') then exit;
l:=gchar;
if l<>'/' then exit
end;
k:=gchar;
l:=gchar;
if l='/'
then if k='0'
then exit
else
else begin
if k>'3' then exit;
if not digit(l) then exit;
if (k='3') and (l>'1') then exit;
l:=gchar;
if l<>'/' then exit
end;
if digit(gchar) and digit(gchar) then validdate:=true
end;
begin
writehdr ('Set Last Call');
writeln (^M'Your last call was: '^S+datestr(laston),' at '+timestr(laston));
writestr (^M'Enter new date [mm/dd/yy]:');
if length(input)>0
then if validdate (input)
then laston:=dateval(input)+timepart(laston)
else writestr ('Invalid date!');
writestr (^M'Enter new time [hh:mm am/pm]:');
if length(input)>0
then if validtime(input)
then laston:=timeval(input)+datepart(laston)
else writestr ('Invalid time!')
end;
procedure removeallforms;
var ndel,cygnus:integer;
u:userrec;
procedure eraseinfo1;
var cnt:integer;
begin
ndel:=0;
for cnt:=1 to numusers do begin
if (cnt mod 10)=0 then write (cnt,', ');
seek (ufile,cnt);
read (ufile,u);
if u.infoform1>=0 then begin
deletetext (u.infoform1);
u.infoform1:=-1;
seek (ufile,cnt);
write (ufile,u);
ndel:=ndel+1
end
end;
end;
procedure eraseinfo2;
var cnt:integer;
begin
ndel:=0;
for cnt:=1 to numusers do begin
if (cnt mod 10)=0 then write (cnt,', ');
seek (ufile,cnt);
read (ufile,u);
if u.infoform2>=0 then begin
deletetext (u.infoform2);
u.infoform2:=-1;
seek (ufile,cnt);
write (ufile,u);
ndel:=ndel+1
end
end;
end;
procedure eraseinfo3;
var cnt:integer;
begin
ndel:=0;
for cnt:=1 to numusers do begin
if (cnt mod 10)=0 then write (cnt,', ');
seek (ufile,cnt);
read (ufile,u);
if u.infoform3>=0 then begin
deletetext (u.infoform3);
u.infoform3:=-1;
seek (ufile,cnt);
write (ufile,u);
ndel:=ndel+1
end
end;
end;
procedure eraseinfo4;
var cnt:integer;
begin
ndel:=0;
for cnt:=1 to numusers do begin
if (cnt mod 10)=0 then write (cnt,', ');
seek (ufile,cnt);
read (ufile,u);
if u.infoform4>=0 then begin
deletetext (u.infoform4);
u.infoform4:=-1;
seek (ufile,cnt);
write (ufile,u);
ndel:=ndel+1
end
end;
end;
procedure eraseinfo5;
var cnt:integer;
begin
ndel:=0;
for cnt:=1 to numusers do begin
if (cnt mod 10)=0 then write (cnt,', ');
seek (ufile,cnt);
read (ufile,u);
if u.infoform5>=0 then begin
deletetext (u.infoform5);
u.infoform5:=-1;
seek (ufile,cnt);
write (ufile,u);
ndel:=ndel+1
end
end;
end;
begin
writehdr ('Erase Infoform[s]');
writestr ('Erase ALL of which Info-Form? [#1-5]: *');
if (valu(input)<1) or (valu(input)>5) then exit;
cygnus:=valu(input);
writestr ('Erase ALL # '+strr(valu(input))+' Info-Forms -- Are you sure [y/n]? *');
if not yes then exit;
writeurec;
writestr (^M'Erasing. please stand by.');
ndel:=0;
case cygnus of
1:eraseinfo1;
2:eraseinfo2;
3:eraseinfo3;
4:eraseinfo4;
5:eraseinfo5;
end;
writeln ('Done.');
writestr (^M'All # '+strr(cygnus)+' Infoforms erased.');
writestr (strr(ndel)+' Users Processed.');
readurec
end;
procedure readfeedback;
var ffile:file of mailrec;
m:mailrec;
me:message;
cur:integer;
function nummessages:integer;
begin
nummessages:=filesize(ffile)
end;
function checkcur:boolean;
begin
if length(input)>1 then cur:=valu(copy(input,2,255));
if (cur<1) or (cur>nummessages) then begin
writestr (^M'Message out of range!');
cur:=0;
checkcur:=true
end else begin
checkcur:=false;
seek (ffile,cur-1);
read (ffile,m)
end
end;
procedure readnum (n:integer);
begin
cur:=n;
input:='';
if checkcur then exit;
writeln (^B^M'Message: '^S,cur,
^M'Title: '^S,m.title,
^M'Sent by: '^S,m.sentby,
^M'Sent on: '^S,datestr(m.when),' at ',timestr(m.when),^M);
if break then exit;
printtext (m.line)
end;
procedure writecurmsg;
begin
if (cur<1) or (cur>nummessages) then cur:=0;
write (^B^R^M'Current msg: '^S);
if cur=0 then write ('None') else begin
seek (ffile,cur-1);
read (ffile,m);
write (m.title,' by ',m.sentby)
end
end;
procedure delfeedback;
var cnt:integer;
begin
if checkcur then exit;
deletetext (m.line);
for cnt:=cur to nummessages-1 do begin
seek (ffile,cnt);
read (ffile,m);
seek (ffile,cnt-1);
write (ffile,m)
end;
seek (ffile,nummessages-1);
truncate (ffile);
cur:=cur-1
end;
procedure editusr;
var n:integer;
begin
if checkcur then exit;
n:=lookupuser (m.sentby);
if n=0
then writestr ('User disappeared!')
else edituser (n)
end;
procedure infoform;
begin
if checkcur then exit;
showinfoforms (m.sentby)
end;
procedure nextfeedback;
begin
cur:=cur+1;
if cur>nummessages then begin
writestr (^M'Sorry, no more feedback!');
cur:=0;
exit
end;
readnum (cur)
end;
procedure readagain;
begin
if checkcur then exit;
readnum (cur)
end;
procedure replyfeedback;
begin
if checkcur then exit;
sendmailto (m.sentby,false)
end;
procedure listfeedback;
var cnt:integer;
begin
if nummessages=0 then exit;
thereare (nummessages,'piece of feedback','pieces of feedback');
if break then exit;
writeln (^M'Num Title Left by'^M);
seek (ffile,0);
for cnt:=1 to nummessages do begin
read (ffile,m);
tab (strr(cnt),4);
if break then exit;
tab (m.title,31);
writeln (m.sentby);
if break then exit
end
end;
Var q:Integer;
Label exit;
Begin
Assign(ffile,bbsdatadir+'Feedback.dat');
Reset(ffile);
If IOResult<>0 Then Rewrite(ffile);
cur:=0;
Repeat
If nummessages=0 Then Begin
writestr('Sorry, no feedback!');
GoTo exit
End;{listfeed}
writecurmsg;
q:=menu ('Feedback','FEED','Q#DEIR_AL?');
If q<0
Then readnum(-q)
Else Case q Of
3:delfeedback;
4:editusr;
5:infoform;
6:replyfeedback;
7:nextfeedback;
8:readagain;
9:listfeedback;
10:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
Feedback Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔════
s');
writeln ('u
═════════════════════════════════╗HC║ [
A
]
s');
writeln ('u
Read Feedback Again
║HC║ [
D
s');
writeln ('u
]
Delete Feedback
║HC║ [
s');
writeln ('u
E
]
Edit User
║H
s');
writeln ('u
C║ [
I
]
Infoforms
s');
writeln ('u
║HC║ [
L
]
List Feedback
s');
writeln ('u
║HC║ [
Q
]
Quit
s');
writeln ('u
║HC║ [
R
]
Reply to F
s');
writeln ('u
eedback
║HC║ [
#
]
Rea
s');
writeln ('u
d Feedback File
║HC║ [
CR
]
s');
writeln ('u
Read Next Feedback
║HC║ [
?
s');
writeln ('u
]
View This Menu
║HC╚═
A');
writeln ('C
════════════════════════════════════╝
');
write (^B^R' '^M);
pause;
end;
End
Until (q=1) Or hungupon;
exit:
Close(ffile)
End;
procedure stat;
begin
ansicolor (urec.statcolor)
end;
procedure prompt;
begin
ansicolor (urec.promptcolor)
end;
procedure yourstatus;
var cnt,gnumsgs,gnufiles,gnugfiles,gnudbases,clicheline:integer;
var u:userrec;
begin
if ansigraphics in urec.config
then write (direct,#27'[2J');
gnumsgs:=(messages-urec.lastmessages);
gnufiles:=(ups-urec.lastups);
gnugfiles:=(gfilez-urec.lastgfiles);
gnudbases:=(dbases-urec.lastdbases);
if gnumsgs<1 then gnumsgs:=0;
if gnufiles<1 then gnufiles:=0;
if gnugfiles<1 then gnugfiles:=0;
if gnudbases<1 then gnudbases:=0;
urec.lastmessages:=messages;
urec.lastups:=ups;
urec.lastgfiles:=gfilez;
urec.lastdbases:=dbases;
ansicolor (urec.promptcolor);
writeln (' ╒═════════════════════╕');
write (' ╒════╡ ');
ansicolor (urec.statcolor);
write ('FAQ '+ver+'/ '+date+'');
ansicolor (urec.promptcolor);
writeln (' ╞════╕');
writeln (^P' │ ╘═════════════════════╛ │');
write (^P' │ '^R'User Name : '); ansicolor (urec.statcolor); tab (unam,17);
ansicolor (urec.promptcolor); writeln (^P'│');
write (^P' ┌─┤ '^R'New Status '^P'├─┐ │ '^R'User Level : ');
ansicolor (urec.statcolor); tab (strr(ulvl),17);
ansicolor (urec.promptcolor); writeln (^P'│');
write (^P' │'^R'Messages : '); stat; if gnumsgs<1 then tab ('None',5) else tab (strr(gnumsgs),5);
write (^P'│ │ '^R'Xfer Level : ');
stat; tab (strr(urec.udlevel),17); prompt; writeln ('│ ┌─┤ '^R'File Xfer '^P'├─┐');
write (^P' │'^R'Databases: '); stat; if gnudbases<1 then tab ('None',5) else tab (strr(gnudbases),5);
write (^P'│ │ '^R'Time Today : ');
stat; tab (strr(urec.timetoday),17); prompt; write (^P'│ │'^R'Num U/Ls : '^S); if urec.uploads<1 then tab ('None',5)
else tab (strr(urec.uploads),5);
writeln (^P'│');
write (^P' │'^R'Files : '); stat; if gnufiles<1 then tab ('None',5) else tab (strr(gnufiles),5);
write (^P'│ │ '^R'# of Calls : ');
stat; tab (strr(urec.numon),17); prompt; write (^P'│ │'^R'Num D/Ls : '^S); if urec.downloads<1 then tab ('None',5)
else tab (strr(urec.uploads),5);
writeln (^P'│');
write (^P' │'^R'G-Files : '); stat; if gnugfiles<1 then tab ('None',5) else tab (strr(gnugfiles),5);
write (^P'│ │ '^R'Mail Status: ');
stat;
cnt:=getnummail (unum);
if cnt<1 then tab ('None',17) else tab (strr(cnt),17);
prompt; write (^P'│ │'^R'F. Points: '^S); if urec.udpoints<1 then tab ('None',5) else tab (strr(urec.udpoints),5);
writeln (^P'│');
write (^P' │'^R'Hack A. : '); stat; if urec.hack=0 then tab ('None',5) else tab (strr(urec.hack),5);
write (^P'│ │ '^R'Last On : ');
stat;
if laston<>0 then
tab (datestr(laston),17) else
tab ('None ',17);
subs1.laston:=laston;
laston:=now;
prompt;
writeln (^P'│ └────────────────┘');
write (^P' └────────────────┘ │ '^R'Last Caller: '); stat; tab (getlastcaller,17); prompt; writeln ('│');
{ if useqr then begin }
calcqr;
write (^P' │ '^R'Rating : '); stat; tab (strr(qr),17); prompt; writeln ('│');
{ end; }
write (^P' │ '^R'Comments : '); stat; tab (urec.note,17); prompt; writeln ('│');
writeln (^P' ╘═══════════════════════════════╛');
writeln;
end;
procedure topposter;
type HighestPCR=record
Name:mstr;
PCR:longint;
end;
var a,b,c,d,e,cnt,UptoDown:longint;
done:boolean;
TMPrec:userrec;
Posters:array [1..5] of highestpcr;
LamePosters:array [1..5] of highestpcr;
Uploaders:array [1..5] of highestpcr;
LameUploaders:array [1..5] of highestpcr;
Downloaders:array [1..5] of highestpcr;
LameDownloaders:array [1..5] of highestpcr;
TmpPost:highestpcr;
begin
Writehdr ('Calculating Statistics');
for cnt:=1 to 5 do begin
Posters[cnt].pcr:=maxint;
posters[cnt].name:='';
lamePosters[cnt].pcr:=0;
lameposters[cnt].name:='';
Downloaders[cnt].pcr:=maxint;
downloaders[cnt].name:='';
lamedownloaders[cnt].pcr:=0;
lamedownloaders[cnt].name:='';
uploaders[cnt].pcr:=maxint;
uploaders[cnt].name:='';
lameuploaders[cnt].pcr:=0;
lameuploaders[cnt].name:='';
end;
for cnt:=1 to numusers do begin
seek(ufile,cnt);
read(ufile,TmpRec);
if tmprec.numon>1 then begin
if tmprec.numon>0 then d:=(tmprec.nbu*100) div tmprec.numon else d:=0;
if d>0 then begin
done:=false;
for e:=1 to 5 do begin
if (done=false) and (posters[e].pcr<d) then begin { sort }
if e<5 then begin
for a:=4 downto e do begin
posters[a+1]:=posters[a];
end;
end;
posters[e].pcr:=d;
posters[e].name:=tmprec.handle;
Done:=true;
end;
end;
end;
begin
done:=false;
for e:=1 to 5 do begin
if (done=false) and (lameposters[e].pcr>d) then begin { sort }
if e>1 then begin
for a:=4 downto e do begin
lameposters[a+1]:=lameposters[a];
end;
end;
lameposters[e].pcr:=d;
lameposters[e].name:=tmprec.handle;
Done:=true;
end;
end;
end;
d:=tmprec.upk;
if d>0 then begin
done:=false;
for e:=1 to 5 do begin
if (done=false) and (Uploaders[e].pcr<d) then begin { sort }
if e<5 then begin
for a:=4 downto e do begin
Uploaders[a+1]:=uploaders[a];
end;
end;
uploaders[e].pcr:=d;
uploaders[e].name:=tmprec.handle;
Done:=true;
end;
end;
end;
begin
done:=false;
for e:=1 to 5 do begin
if (done=false) and (lameuploaders[e].pcr>d) then begin { sort }
if e>1 then begin
for a:=4 downto e do begin
lameuploaders[a+1]:=lameuploaders[a];
end;
end;
lameuploaders[e].pcr:=d;
lameuploaders[e].name:=tmprec.handle;
Done:=true;
end;
end;
end;
d:=tmprec.downk;
if d>0 then begin
done:=false;
for e:=1 to 5 do begin
if (done=false) and (downloaders[e].pcr<d) then begin { sort }
if e<5 then begin
for a:=4 downto e do begin
downloaders[a+1]:=downloaders[a];
end;
end;
downloaders[e].pcr:=d;
downloaders[e].name:=tmprec.handle;
Done:=true;
end;
end;
end;
begin
done:=false;
for e:=1 to 5 do begin
if (done=false) and (lamedownloaders[e].pcr>d) then begin { sort }
if e>1 then begin
for a:=4 downto e do begin
lamedownloaders[a+1]:=lamedownloaders[a];
end;
end;
lamedownloaders[e].pcr:=d;
lamedownloaders[e].name:=tmprec.handle;
Done:=true;
end;
end;
end;
end;
end;
clearscr;
writeln(^R'┌─'^P'['^S' Top Five Posters'^P' ]'^R'────────────────┐┌─'^P'['^S' Top Five Lowest Posters'^P' ]'^R'─────────┐');
writeln(^R'│'^S'User Name Post Call Ratio'^S'││'^S'User Name Post Call Ratio'^S'│');
writeln(^R'│'^S'1. '^P'[ ]'^R'││'^S'1. '^P'[ ]'^R'│');
writeln(^R'│'^S'2. '^P'[ ]'^R'││'^S'2. '^P'[ ]'^R'│');
writeln(^R'│'^S'3. '^P'[ ]'^R'││'^S'3. '^P'[ ]'^R'│');
writeln(^R'│'^S'4. '^P'[ ]'^R'││'^S'4. '^P'[ ]'^R'│');
writeln(^R'│'^S'5. '^P'[ ]'^R'││'^S'5. '^P'[ ]'^R'│');
writeln(^R'└─────────────────────────────────────┘└─────────────────────────────────────┘');
movexy(4,3);write(posters[1].name);
movexy(4,4);write(posters[2].name);
movexy(4,5);write(posters[3].name);
movexy(4,6);write(posters[4].name);
movexy(4,7);write(posters[5].name);
movexy(32,3);write(posters[1].pcr:5,'%');
movexy(32,4);write(posters[2].pcr:5,'%');
movexy(32,5);write(posters[3].pcr:5,'%');
movexy(32,6);write(posters[4].pcr:5,'%');
movexy(32,7);write(posters[5].pcr:5,'%');
movexy(43,3);write (lameposters[1].name);
movexy(43,4);write (lameposters[2].name);
movexy(43,5);write (lameposters[3].name);
movexy(43,6);write (lameposters[4].name);
movexy(43,7);write (lameposters[5].name);
movexy(71,3);write (lameposters[1].pcr:5,'%');
movexy(71,4);write (lameposters[2].pcr:5,'%');
movexy(71,5);write (lameposters[3].pcr:5,'%');
movexy(71,6);write (lameposters[4].pcr:5,'%');
movexy(71,7);write (lameposters[5].pcr:5,'%');
movexy(1,14);writestr(^R'Press '^P'['^S'Return'^P']'^S': '^U'*');
end;
procedure spacespace (i:integer);
var ii:integer;
begin
for ii:=1 to i do write (' ');
end;
end.